(* ========================================================================== *)
(*  Library                                                                   *)
(* ========================================================================== *)

open Format

(* -------------------------------------------------------------------------- *)
(*  Exceptions                                                                *)
(* -------------------------------------------------------------------------- *)

exception Not_implemented

(* -------------------------------------------------------------------------- *)
(*  bool                                                                      *)
(* -------------------------------------------------------------------------- *)

let xor x y = (x && not y) || (not x && y)

(* ------------------------------------------------------------------------- *)
(* Combinators.                                                              *)
(* ------------------------------------------------------------------------- *)

let ( ** ) = fun f g x -> f(g x)
let ( *** ) = fun f g x -> g(f x)
let ( % ) = ( ** )
let (|>) x f = f x
let (|->) (x, y) f = f x y
let (|>>) (x, y) f = (f x, y)
let (||>) (x, y) f = (x, f y)
let ( >> ) f g = g ** f
let (||>>) (x, y) f = let (z, y') = f y in ((x, z), y')
let curry f x y = f(x,y)
let uncurry f(x,y) = f x y
let i x = x
let id = i
let k x y = x
let s x y z = x z (y z)
let c f x y = f y x
let w f x = f x x
let apply f x = f x

(* ------------------------------------------------------------------------- *)
(*  Functions								     *)
(* ------------------------------------------------------------------------- *)

let rec funpow n f x =
  if n < 1 then x else funpow (n-1) f (f x)

let rec repeat f x =
  try let y = f x in repeat f y with Failure _ -> x

let eq = (=)

(* ------------------------------------------------------------------------- *)
(*  Pairs                                                                    *)
(* ------------------------------------------------------------------------- *)

let pair x y = x,y
let rpair x y = y,x
let apfst f (x, y) = (f x, y)
let apsnd f (x, y) = (x, f y)
let papply f (x, y) = (f x, f y)
let papply2 f g (x, y) = (f x, g y)
let swap (a,b) = b,a

(* ------------------------------------------------------------------------- *)
(*  Order                                                                    *)
(* ------------------------------------------------------------------------- *)

type order = Less | Greater | Equal

let int_ord (x:int) y = 
  if x < y then Less else 
    if y < x then Greater else Equal

let string_ord (x:string) y = 
  if x < y then Less else 
    if y < x then Greater else Equal

(* ------------------------------------------------------------------------- *)
(*  Checking for failure						     *)
(* ------------------------------------------------------------------------- *)

let can f x = try (f x; true) with Failure _ -> false
let cant f x = not (can f x)
let check p x = if p x then x else failwith "check"

(* ------------------------------------------------------------------------- *)
(*  Ints                                                                     *)
(* ------------------------------------------------------------------------- *)

let rec sum l = match l with [] -> 0 | h::t -> h + sum t
let abs x = if x < 0 then -x else x

type sign = Positive | Negative

let sgn(x) = if x >= 0 then Positive else Negative

let gcd =
  let rec gxd x y =
    if y = 0 then x else gxd y (x mod y) in
    fun x y -> if x < y then gxd y x else gxd x y

let lcm x y = (x * y) / gcd x y

let odd n = (n mod 2 = 1) 

let even n = (n mod 2 = 0) 

let ( ^^ ) m n = funpow n (( * ) m) 1

let isqrt n = 
  let n' = int_of_float (sqrt (float_of_int n)) in
  let exact = n' * n' = n in
    n',exact

let posmod n m = (n mod m + m) mod m

let posmod' n m = posmod n (abs m)

let rec ilog n m = if n < m then 0 else 1 + ilog (n / m) m

let fact n = 
  if n <= 0 then failwith "fact: negative or 0" else
  let rec fact' n s = match n with
    | 1 -> s
    | _ -> fact' (n - 1) (s * n) in
    fact' n 1

(* -------------------------------------------------------------------------- *)
(*  Floats                                                                    *)
(* -------------------------------------------------------------------------- *)

let float_precision = ref 5
let float_to_string f = Printf.sprintf "%.*e" (!float_precision) f
let genlog f k = log10 f /. log10 k
let is_nan x = classify_float x = FP_nan
let fabs x = if x > 0.0 then x else -. x
let pi = 4. *. atan 1.
    
(* ------------------------------------------------------------------------- *)
(*  Debug								     *)
(* ------------------------------------------------------------------------- *)

let report s =
  print_string s; print_newline()
let warn cond s =
  if cond then report ("Warning: "^s) else ()
let verbose = ref true
let report_timing = ref true
let remark s =
  if !verbose then report s else ()
let time f x =
  if not (!report_timing) then f x else
    let start_time = Sys.time() in
      try 
	let result = f x in
	let finish_time = Sys.time() in
	  report("CPU time (user): "^(string_of_float(finish_time -. start_time)));
	  result
      with e ->
	let finish_time = Sys.time() in
	  print_string("Failed after (user) CPU time of "^
			 (string_of_float(finish_time -. start_time))^": ");
	  raise e

let get_time f x =
  let start_time = Sys.time() in
    try
      let result = f x in
      let finish_time = Sys.time() in
      let total_time = finish_time -. start_time in
	(result,total_time)
    with e ->
      let finish_time = Sys.time() in
      let total_time = finish_time -. start_time in
	(print_string("Failed after (user) CPU time of "^
			(string_of_float(total_time) ^": "));
	 raise e)

(* ------------------------------------------------------------------------- *)
(*  Triples								     *)
(* ------------------------------------------------------------------------- *)

let fst3 (a,_,_) = a
let snd3 (_,a,_) = a
let thd3 (_,_,a) = a

let rec zip3 l1 l2 l3 = match l1,l2,l3 with 
    [],[],[] -> []
  | h1::t1,h2::t2,h3::t3 -> (h1,h2,h3)::zip3 t1 t2 t3
  | _ -> failwith "zip3"

let rec unzip3 = function 
    [] -> [],[],[]
  | (h1,h2,h3)::t -> 
      let t1,t2,t3 = unzip3 t in
	(h1::t1),(h2::t2),(h3::t3)

(* ------------------------------------------------------------------------- *)
(*  Lists								     *)
(* ------------------------------------------------------------------------- *)

(* Library *)
let length = List.length
let hd = List.hd
let tl = List.tl
let nth = List.nth
let rev = List.rev
let append = List.append
let rev_append = List.rev_append
let flatten = List.flatten
let iter = List.iter
let map = List.map
let rev_map = List.rev_map
let fold_left = List.fold_left
let fold_right = List.fold_right
let iter2 = List.iter2
let map2 = List.map2
let rev_map2 = List.rev_map2
let fold_left2 = List.fold_left2
let fold_right2 = List.fold_right2
let forall = List.for_all
let exists = List.exists
let forall2 = List.for_all2
let exists2 = List.exists2
let mem = List.mem
let memq = List.memq
let find = List.find
let filter = List.filter
let partition = List.partition
let assoc = List.assoc
let assq = List.assq
let mem_assoc = List.mem_assoc
let mem_assq = List.mem_assoc
let remove_assoc = List.remove_assoc
let remove_assq = List.remove_assq
let zip = List.combine
let unzip = List.split
let gen_sort = List.sort
let sort l = List.sort Pervasives.compare l
let stable_sort = List.stable_sort
let fast_sort = List.fast_sort



(** Extras *)
let try_assoc x l s = try assoc x l with Not_found -> failwith ("try_assoc: " ^ s)

let insert x l = if mem x l then l else x::l

let diff l1 l2 = filter (not ** c mem l2) l1

let null = function 
    [] -> true
  | _ -> false

let cons x y = x :: y
let list x = [x]

let mapi (f : int -> 'a -> 'b) = 
  let rec mapi n l = 
    match l with 
        [] -> []
      | h::t -> f n h::mapi (n + 1) t in
    mapi 0

let rec last l =
  match l with
      [x] -> x
    | (h::t) -> last t
    | [] -> failwith "last"

let rec butlast l =
  match l with
      [_] -> []
    | (h::t) -> h::(butlast t)
    | [] -> failwith "butlast"

let rec gen_max (<) l = 
  match l with 
      [] -> failwith "maxl"
    | [x] -> x
    | h::t -> let t' = gen_max (<) t in if t' < h then h else t'

let maxl l = gen_max (<) l

let rec gen_min (<) l = 
  match l with 
      [] -> failwith "gen_min"
    | [x] -> x
    | h::t -> let t' = gen_min (<) t in if h < t' then h else t'

let minl l = gen_min (<) l

let itlist = fold_right
let foldr = fold_right
let foldl = fold_left

let rec rev_itlist f l b =
  match l with
      [] -> b
    | (h::t) -> rev_itlist f t (f h b)

let rec end_itlist f l =
  match l with
      []     -> failwith "end_itlist"
    | [x]    -> x
    | (h::t) -> f h (end_itlist f t)

let rec rev_end_itlist f l = match l with
    [] -> failwith "rev_end_itlist"
  | [x] -> x
  | h::t -> f (rev_end_itlist f t) h 

let itlist2 = List.fold_right2

let rec rev_itlist2 f l1 l2 b =
  match (l1,l2) with
      ([],[]) -> b
    | (h1::t1,h2::t2) -> rev_itlist2 f t1 t2 (f h1 h2 b)
    | _ -> failwith "rev_itlist2"

let nitlist f l b = 
  let rec nitlist n f l b = match l with
      [] -> b
    | h::t -> f n h (nitlist (n + 1) f t b) in
    nitlist 0 f l b

let rev_nitlist f l b = 
  let rec rev_nitlist n f l b =
    match l with
        [] -> b
      | (h::t) -> rev_nitlist (n + 1) f t (f n h b) in
    rev_nitlist 0 f l b

let fold_left_end f l = fold_left f (hd l) (tl l)
let fold_right_end f l = fold_right f (butlast l) (last l) 
let foldr_end = fold_right_end
let foldl_end = fold_left_end

let niter f l = rev_nitlist (fun n x () -> f n x) l ()

let rec foldl f e l = match l with 
    [] -> e
  | h::t -> foldl f (f e h) t

let pfold_left (f: 'a * 'b -> 'a) : 'a * 'b list -> 'a =
  let rec itl (e,l) = match l with 
      [] -> e
    | a::l -> itl (f(e, a), l)
  in  itl 

let pfold_right f (l, e) =
  let rec itr l = match l with
      [] -> e
    | a::l -> f(a, itr l)
  in itr l

let foldl_map f =
  let rec fold_aux (x, l) = match l with
      [] -> (x, [])
    | y::ys -> 
        let (x', y') = f (x, y) in
        let (x'', ys') = fold_aux (x', ys) in
          (x'', y' :: ys') in
    fold_aux 

let rec replicate x n =
  if n < 1 then []
  else x::(replicate x (n - 1))

let rec uptoby k m n = if m > n then [] else m::(uptoby k (m + k) n)
let upto = uptoby 1
let ( -- ) = upto
let ( --< ) m n = upto m (n - 1)


let filter_out p l = filter (not ** p) l

let rec tryfind f l =
  match l with
      [] -> failwith "tryfind"
    | (h::t) -> try f h with Failure _ -> tryfind f t

let rec remove p l =
  match l with
      [] -> raise Not_found
    | (h::t) -> if p(h) then h,t else
          let y,n = remove p t in y,h::n

let rem x l = snd(remove ((=) x) l)
let rem' x l = try rem x l with Not_found -> l

let delete = rem
let delete' = rem'
let rec delete_all x l = 
  match l with
      [] -> []
    | (h::t) -> if h = x then delete_all x t else
          let t' = delete_all x t in h::t'

let rec chop_list n l =
  if n = 0 then [],l else
    try let m,l' = chop_list (n-1) (tl l) in (hd l)::m,l'
    with Failure _ -> [],l

let rec split_list n l = 
  let l1,l' = chop_list n l in
  match l' with 
    | [] -> [l1]
    | _ -> l1::split_list n l'

let rec chop_head p l = match l with
  | [] -> []
  | h::t -> if p h then chop_head p t else l

let take n l = fst (chop_list n l)
let drop n l = snd (chop_list n l)

let indices x = 
  let rec ind n l =
    match l with 
        [] -> []
      | h::t -> 
          let t' = ind (n + 1) t in 
            if h = x then n::t' else t' in
    ind 0

let rec shuffle l1 l2 = 
  match l1,l2 with 
      [],l2 -> l2
    | l1,[] -> l1
    | (h1::t1),(h2::t2) -> h1::h2::shuffle t1 t2

let rec rev_assoc x = function 
    [] -> failwith "rev_assoc"
  | (a,b)::t -> if x = b then a else rev_assoc x t

let allpairs f l1 l2 =
  itlist ((@) ** (c map l2) ** f) l1 []

let rec allcombs f l =
  match l with 
      [] -> []
    | h::t -> 
        map (f h) t @ allcombs f t

let product l1 l2 = allpairs pair l1 l2

let mappair f g l =
  let a,b = unzip l in
  let la = map f a in
  let lb = map g b in
    zip la lb

let add x l = if mem x l then l else x::l

let rec insertat i x l =
  if i = 0 then x::l else
    match l with
	[] -> failwith "insertat: list too short for position to exist"
      | h::t -> h::(insertat (i-1) x t)

let rev_nth i l = nth l (length l - i - 1) 

(*
  swap_lists [[1;2;3];[4;5;6];[7;8;9];[10;11;12]] 
  --> 
  [[1; 4; 7; 10]; [2; 5; 8; 11]; [3; 6; 9; 12]]
 *)
let swap_lists l = 
  let rec swap_lists l store = 
    match l with
	[] -> store
      | h::t -> 
          let store' = map2 cons h store in
            swap_lists t store' in
  let n = length (hd l) in
  let l' = swap_lists l (replicate [] n) in
    map rev l'

let rec gen_mem f x l = match l with
    [] -> false
  | h::t -> f x h || gen_mem f x t

let gen_rem eq x xs =
  if gen_mem eq x xs
  then filter_out (fun y -> eq x y) xs
  else xs

let cycle l = match l with
  | [] -> []
  | h::t -> t @ [h] 

let rotate = 
  let rec rotate l n = match n with
    | 0 -> l
    | _ -> rotate (cycle l) (n - 1) in
    fun l n -> if n < 0 then failwith "rotate: negative" else
        rotate l n

let split_at =
  let rec split_at x ys = function
    | [] -> ys,[]
    | z::zs -> if x = z then ys,zs else split_at x (ys @ [z]) zs in
    fun x xs -> split_at x [] xs

let update l n = if n < 0 then failwith "update: negative" else
    let rec update l n a = match l with
      | [] -> []
      | v::vs -> if n = 0 then a::vs else v::update vs (n-1) a in
      fun a -> update l n a

let rec map_at l f xs = match l with
  | [] -> xs
  | n::ns -> if n < length xs then map_at ns f (update xs n (f (nth xs n)))
    else map_at ns f xs

let rec replace x ys zs = match zs with 
  | [] -> []
  | z::zs -> if z = x then ys @ zs else z::(replace x ys zs)

let gen_index p l =
  let rec gen_index l s = match l with
    | [] -> failwith "gen_index"
    | h::t -> if p h then s else gen_index t (s + 1) in
    gen_index l 0 

let index x l = gen_index ((=) x) l

(* ------------------------------------------------------------------------- *)
(* Convert list into set by eliminating duplicates.                          *)
(* ------------------------------------------------------------------------- *)

let rec uniq l = match l with
  | x::(y::_ as ys) -> if x = y then uniq ys else x::(uniq ys)
  | _ -> l

let setify =
  let rec canonical lis =
     match lis with
       x::(y::_ as rest) -> x < y & canonical rest
     | _ -> true in
  fun l -> if canonical l then l else uniq (sort l)

let union =
  let rec union l1 l2 =
    match (l1,l2) with
        ([],l2) -> l2
      | (l1,[]) -> l1
      | ((h1::t1 as l1),(h2::t2 as l2)) ->
          if h1 = h2 then h1::(union t1 t2)
          else if h1 < h2 then h1::(union t1 l2)
          else h2::(union l1 t2) in
  fun s1 s2 -> union (setify s1) (setify s2)

let intersect =
  let rec intersect l1 l2 =
    match (l1,l2) with
        ([],l2) -> []
      | (l1,[]) -> []
      | ((h1::t1 as l1),(h2::t2 as l2)) ->
          if h1 = h2 then h1::(intersect t1 t2)
          else if h1 < h2 then intersect t1 l2
          else intersect l1 t2 in
  fun s1 s2 -> intersect (setify s1) (setify s2)

let subtract =
  let rec subtract l1 l2 =
    match (l1,l2) with
        ([],l2) -> []
      | (l1,[]) -> l1
      | ((h1::t1 as l1),(h2::t2 as l2)) ->
          if h1 = h2 then subtract t1 t2
          else if h1 < h2 then h1::(subtract t1 l2)
          else subtract l1 t2 in
  fun s1 s2 -> subtract (setify s1) (setify s2)

let subset,psubset =
  let rec subset l1 l2 =
    match (l1,l2) with
        ([],l2) -> true
      | (l1,[]) -> false
      | ((h1::t1 as l1),(h2::t2)) ->
          if h1 = h2 then subset t1 t2
          else if h1 < h2 then false
          else subset l1 t2
  and psubset l1 l2 =
    match (l1,l2) with
        (l1,[]) -> false
      | ([],l2) -> true
      | ((h1::t1 as l1),(h2::t2)) ->
          if h1 = h2 then psubset t1 t2
          else if h1 < h2 then false
          else subset l1 t2 in
  (fun s1 s2 -> subset (setify s1) (setify s2)),
  (fun s1 s2 -> psubset (setify s1) (setify s2))

let rec set_eq s1 s2 = (setify s1 = setify s2)

let insert x s = union [x] s

let smap f s = setify (map f s)

let unions s = setify(itlist (@) s [])

let rec allsets m l =
  if m = 0 then [[]] else
  match l with
    [] -> []
  | h::t -> map (fun g -> h::g) (allsets (m - 1) t) @ allsets m t

let rec allsubsets s =
  match s with
    [] -> [[]]
  | (a::t) -> let res = allsubsets t in
              map (fun b -> a::b) res @ res

let allnonemptysubsets s = subtract (allsubsets s) [[]]

let distinctpairs l =
  filter (fun (a,b) -> a < b) (allpairs (fun a b -> a,b) l l)

let non p x = not(p x)

let rec permutations vals = match vals with
  | [] -> [[]]
  | _ -> 
      let itfun v store = 
        let rest = permutations (rem v vals) in
          map (cons v) rest @ store in
        itlist itfun vals []

let rec combinations vals = match vals with
    [] -> [[]]
  | l::ls -> let rest = combinations ls in
               flatten (map (fun x -> map (cons x) rest) l)

(* ---------------------------------------------------------------------- *)
(*  Refs                                                                  *)
(* ---------------------------------------------------------------------- *)

let (+=) a b = a := !a + b
let ( -= ) a b = a := !a - b
let ( *= ) a b = a := !a * b
let ( /= ) a b = a := !a / b
let (+.=) a b = a := !a +. b
let ( @= ) a b = a := !a @ b
let ( +:= ) l x = l := x::!l
let ( -:= ) l x = l := rem' x !l
let skip x = ()

(* ------------------------------------------------------------------------- *)
(*  Options                                                                  *)
(* ------------------------------------------------------------------------- *)

let is_some x = match x with Some _ -> true | _ -> false
let is_none x = match x with None -> true | _ -> false
let get_opt x s = match x with Some y -> y | None -> failwith s
let gen_opt x y = match x with Some x -> x | None -> y
let try_app f x = try Some (f x) with _ -> None
let the x = match x with Some y -> y | None -> failwith "the"

let rec find' p = function
    [] -> None
  | h::t -> if p h then Some h else find' p t

let assoc' x l = 
  match find' (fun p -> fst p = x) l with 
      Some (_,y) -> Some y
    | None -> None

let rev_assoc' x l = 
  match find' (fun p -> snd p = x) l with
      Some (x,_) -> Some x
    | None -> None

let map_partial f l = map the (filter is_some (map f l))

let gen_index' p = 
  let rec ind n = function 
      [] -> None
    | (h::t) -> if p h then Some n else ind (n + 1) t in
    ind 0

let index' x = gen_index' ((=) x)
let apply' f ao = match ao with Some x -> Some (f x) | None -> None
let rec find_opt f l = match l with
  | [] -> None 
  | h::t -> let fh = f h in if is_some fh then fh else find_opt f t

(* ------------------------------------------------------------------------- *)
(* We have "lazy" objects to delay calculation and avoid recalculation.      *)
(* ------------------------------------------------------------------------- *)

type ('a,'b)lazysum = Unrealized of (('a ->'b) * 'a) | Realized of ('b)

let lazify f x = ref(Unrealized(f,x))

let eager y = ref(Realized(y))

let eval r =
  match !r with
      Realized(y) -> y
    | Unrealized(f,x) -> let y = f(x) in (r := Realized(y); y)

(* ------------------------------------------------------------------------- *)
(*  Strings								     *)
(* ------------------------------------------------------------------------- *)

let concat l = itlist (^) l ""

let implode l = itlist (^) l ""

let explode s =
  let rec exap n l =
    if n < 0 then l else
      exap (n - 1) ((String.sub s n 1)::l) in
    exap (String.length s - 1) []

let paren s = "(" ^ s ^ ")"
let bracket s = "[" ^ s ^ "]"
let arrbracket s = "[|" ^ s ^ "|]"
let quote s = "\"" ^ s ^ "\""
let curly s = "{" ^ s ^ "}"
let abracket s = "<" ^ s ^ ">"
let separate s l = concat (shuffle l (replicate s (length l - 1))) 
let commas = separate ","
let semis = separate ";"
let scommas = separate ", "
let ssemis = separate "; "
let spaces = separate " "
let n_spaces n = concat(replicate " " n)
let string_of_list p = bracket ** ssemis ** map p
let string_of_array p = arrbracket ** ssemis ** map p ** Array.to_list
let string_of_pair p1 p2 (x,y) = "(" ^ p1 x ^ "," ^ p2 y ^ ")"

let string_of_option f = function 
    None -> "None"
  | Some x -> "Some: " ^ f x

let string_of_char_list l = 
  let n = length l in
  let l' = Array.of_list l in
  let s = String.create n in
  begin 
    for i = 0 to n - 1 do
      String.set s i l'.(i);
    done;
    s
  end

let split_string c s = 
  let store = ref [] in
  let cur = ref [] in
  let n = String.length s in
  begin
    for i = 0 to n do
      if i = n || String.get s i = c then
        (store := string_of_char_list (rev !cur)::!store;
         cur := [])
      else
        cur := String.get s i::!cur
    done;
    rev !store
  end

(* -------------------------------------------------------------------------- *)
(*  Chars                                                                     *)
(* -------------------------------------------------------------------------- *)

let char_to_string c = String.make 1 c;;
let lowers = explode "abcdefghijklmnopqrstuvwxyz";;
let uppers = explode "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";;
let digits = explode "0123456789";;
let is_upper c = mem (char_to_string c) uppers;;
let is_lower c = mem (char_to_string c) lowers;;
let is_numeral c = mem (char_to_string c) digits;;
let capitalize = String.capitalize
let lowercase = String.lowercase

(* ------------------------------------------------------------------------- *)
(*  Printing								     *)
(* ------------------------------------------------------------------------- *)

let print_stringl s = (print_string s;print_newline())

let print_box_string s =
  let n = String.length s in
  let border = "|" ^ (concat (replicate "-" (n + 2))) ^ "|" in
  let s' = "| " ^ s ^ " |" in
    begin 
      open_vbox 0;
      print_string border;
      print_cut();
      print_string s';
      print_cut();
      print_string border;
      close_box()
    end

let gen_print_list f g l = 
  let rec print_list n = function 
      [] -> ()
    | [h] -> f n h
    | h1::h2::t ->
	begin
	  f n h1;
	  g n;
	  print_list (n + 1) (h2::t)
	end in
    begin 
      open_vbox 1;
      print_string "[";
      print_list 0 l;
      print_string "]";
      close_box();
    end

let print_list f = gen_print_list (fun n x -> f x) (fun x -> print_string "; ")
let print_list_nl f = gen_print_list (fun n x -> f x) (fun x -> print_string "; ";print_cut())

let print_int_list = print_list print_int

let print_pair f g (x,y) = 
  begin 
    open_vbox 1;
    print_string "(";
    f x;
    print_string ",";
    g y;
    print_string ")";
    close_box() 
  end

let print_ref p x = p !x    

let print_option f = function 
    None -> print_string "None"
  | Some x -> (print_string "Some: ";f x)

let print_float f = print_string (float_to_string f)
let newlines n = concat (replicate "\n" n)

(* ------------------------------------------------------------------------- *)
(*  Arrays                                                                   *)
(* ------------------------------------------------------------------------- *)

module Array' =
struct

  module A = Array

  include Array 

  exception Done

  let foldl = fold_left
  let foldr = fold_right
  let foldr_end f l = if A.length l = 0 then failwith "foldr_end: empty" else
    foldr f l l.(0)
  let foldl_end f l = if A.length l = 0 then failwith "foldl_end: empty" else
    foldr f l l.(0)

  let find p arr =  
    let n = ref (-1) in
      try
	for i = 0 to A.length arr - 1 do
          if p (A.get arr i) then (n := i; raise Done)
          else ()
	done;
	None
      with Done -> Some (A.get arr (!n))

  let index x arr =  
    let n = ref (-1) in
      try
	for i = 0 to A.length arr - 1 do
          if x = (A.get arr i) then (n := i; raise Done)
          else ()
	done;
	None
      with Done -> Some (!n)

  let indices x arr =  
    let l = ref [] in
      for i = 0 to A.length arr - 1 do
	if x = (A.get arr i) then (l := i::!l)
	else ()
      done;
      rev !l
	
  let exists p x = is_some (find p x)
  let forall p x = not (exists (not ** p) x)
  let blit' ~source ~dest = A.blit source 0 dest 0 (A.length source)

  let gen_min lt arr = 
    let n = A.length arr in
    if n = 0 then failwith "gen_min: empty" else
    let ret = ref arr.(0) in
      begin 
        for i = 0 to n - 1 do
          if lt arr.(i) !ret then ret := arr.(i)
        done;
        !ret
      end

  let min arr = gen_min (<) arr

  let gen_max gt arr = 
    let n = A.length arr in
    if n = 0 then failwith "gen_max: empty" else
    let ret = ref arr.(0) in
      begin 
        for i = 0 to n - 1 do
          if gt arr.(i) !ret then ret := arr.(i)
        done;
        !ret
      end

  let max arr = gen_max (>) arr


  let map2 f l1 l2 = A.mapi (fun i x -> f x l2.(i)) l1

  let map2i f l1 l2 = A.mapi (fun i x -> f i x l2.(i)) l1

  (* this is really inefficient *)
  let itlist2 f l1 l2 b = itlist2 f (A.to_list l1) (A.to_list l2) b

  let swap a i j = 
    let k = a.(i) in
      (a.(i) <- a.(j);
       a.(j) <- k)

  let unzip arr = if arr = [||] then [||],[||] else
    let n = A.length arr in
    let e0 = arr.(0) in
    let a1,a2 = A.create n (fst e0),A.create n (snd e0) in
    for i = 1 to n-1 do
      let ei = arr.(i) in
        a1.(i) <- fst ei;
        a2.(i) <- snd ei
    done;
      a1,a2

  let zip l1 l2 = map2 pair l1 l2

  let forall2 f x y = 
    let itfun i a = if not (f a y.(i)) then failwith "forall2" else () in
    try
      iteri itfun x;
      true
    with Failure _ -> false

  let exists2 f x y = 
    let itfun i a = if f a y.(i) then failwith "exists2" else () in
    try
      iteri itfun x;
      false
    with Failure _ -> true

  let transpose mat = 
    let n = A.length mat in
    let m = A.length mat.(0) in
    let mat' = A.make_matrix m n mat.(0).(0) in
    begin 
      for i = 0 to n-1 do
        for j = 0 to m-1 do
          mat'.(j).(i) <- mat.(i).(j)        
        done
      done;
      mat'
    end

end

(* -------------------------------------------------------------------------- *)
(*  Stack                                                                     *)
(* -------------------------------------------------------------------------- *)

module Stack' =
struct
  module S = Stack
  open Format
  let to_list s = let l = ref [] in (S.iter (fun x -> l +:= x) s;!l)
  let to_string p s = string_of_list p (to_list s)
  let print p s = 
    begin 
      open_vbox 1;
      print_string "[";
      S.iter (fun x -> p x;print_string ",";print_cut()) s;
      print_string "]";
      close_box()
    end      
end  

(* -------------------------------------------------------------------------- *)
(*  Sets                                                                      *)
(* -------------------------------------------------------------------------- *)

module Set' =
struct 

  module type OrderedType = Set.OrderedType

  module type S =
  sig
    include Set.S
    val forall : (elt -> bool) -> t -> bool
    val insert : elt -> t -> t
    val insert_many : elt list -> t -> t
    val pop : t -> elt * t
    val pop' : t -> (elt * t) option
    val of_list : elt list -> t
    val to_list : t -> elt list
    module Ops :
    sig
      val ( *= ) : t ref -> t -> unit
      val ( += ) : t ref -> t -> unit
      val ( -= ) : t ref -> t -> unit
      val ( %= ) : t ref -> elt -> unit
    end
  end

  module Make(Ord : OrderedType) (* : S with type elt = Ord.t *) =
  struct
    module S = Set.Make(Ord)
    include S
    let forall = for_all
    let insert = add
    let insert_many = fold_right insert 
    let pop s = if is_empty s then failwith "pop" else
	let e = choose s in
	  e,remove e s
    let pop' s = if is_empty s then None else
	let e = choose s in
	  Some(e,remove e s)
    let of_list l = fold_right insert l empty
    let to_list s = 
      let l = ref [] in
      let itfun e = l +:= e in
	begin 
	  iter itfun s;
	  !l
	end
    module Ops =
    struct
      let ( *= ) sr s = sr := inter !sr s
      let ( += ) sr s = sr := union !sr s
      let ( -= ) sr s = sr := diff !sr s
      let ( %= ) sr e = sr := add e !sr
    end
  end

end

module IntSet = Set'.Make(struct type t = int let compare = compare end)
module StringSet = Set'.Make(struct type t = string let compare = compare end)

(* -------------------------------------------------------------------------- *)
(*  Queues                                                                    *)
(* -------------------------------------------------------------------------- *)

module Queue' =
struct 
  module Q = Queue

  let to_list = Q.fold (c cons) [] 

  exception Found 

  let mem q x = 
    try
      Q.iter (fun a -> if x = a then raise Found) q;
      false
    with Found -> true

  let add_unique x q = 
    if not (mem q x) then Q.add x q

  let to_list q = Q.fold (c cons) [] q
  let to_string f q = string_of_list f (to_list q)
  let print f q = print_list f (to_list q)
end

(* -------------------------------------------------------------------------- *)
(*  Hashtables                                                                *)
(* -------------------------------------------------------------------------- *)

module Hashtbl' =
struct 
  module T = Hashtbl
  include T
  let find' t x = try Some (T.find t x) with Not_found -> None
  let unique_add tab a b = if T.mem tab a then failwith "unique_add" else T.add tab a b
  let to_list t = T.fold (fun k v acc -> (k,v)::acc) t []
  let to_string f t = string_of_list f (to_list t)
  let print f t = print_list f (to_list t)
end 

(* -------------------------------------------------------------------------- *)
(*  Misc signatures                                                           *)
(* -------------------------------------------------------------------------- *)

module type NONEMPTY =
sig
  type t
  val default : t
end  

module type SIZE =
sig
  val size : int
end

module type KEY =
sig
  type key
  val ord : key -> key -> order
  val to_string : key -> string
end

module IntKey = 
struct
  type key = int
  let ord = int_ord 
  let to_string = string_of_int 
end

module StringKey = 
struct
  type key = string
  let ord = string_ord
  let to_string = i 
end

(* -------------------------------------------------------------------------- *)
(*  IO                                                                        *)
(* -------------------------------------------------------------------------- *)

let write_file file s =
  let f = open_out file in
    begin 
      output_string f s;
      close_out f
    end

let read_file file =
  let s = ref "" in
  let f = open_in file in
    begin 
      try
        while true do
          s := !s ^ input_line f ^ "\n";
        done;
        failwith "read_file: shouldn't be here"
      with End_of_file -> (close_in f; !s)
    end

let output_stringl f s = output_string f (s ^ "\n")
